;; dashobj5.lsp
;; Contains do-click, do-key, DO-MOTION
;; Copyright (c) 1994-2002 by Forrest W. Young

(defun hide-datasheet ()
  (when (and $$$ (send $$$ :showing))
        (send $$$ :hide-window))
  $$$)

(defun show-datasheet (&optional dash)
  (cond 
    (dash (send dash :show-datasheet))
    ((or (equal @ $$$) (equal @ *cdsupr*)) (send @ :show-datasheet))
    ((and $$$ (send $$$ :showing)) (send $$$ :show-datasheet))
    (*cdsupr* (send *cdsupr* :show-datasheet))
    ($$$ (send $$$ :show-datasheet))))
    
(defmeth datasheet-proto :dob-parents  (&optional (object-id-list nil set))
"Message args: (&optional object-id-list)
 Sets or retrieves the list of parent data and model objects." 
  (if set (setf (slot-value 'dob-parents) object-id-list))
  (slot-value 'dob-parents))

(defmeth datasheet-proto :dob-children (&optional (object-id-list nil set))
"Message args: (&optional object-id-list)
 Sets or retrieves the list of children data and model objects." 
  (if set (setf (slot-value 'dob-children) object-id-list))
  (slot-value 'dob-children))


(defmeth datasheet-proto :add-parent (parent-object)
  (send self :dob-parents 
      (add-element-to-list (send self :dob-parents) parent-object)))


(defmeth datasheet-proto :add-parent (parent-object)
  (send self :dob-parents 
      (add-element-to-list (send self :dob-parents) parent-object)))

(defmeth datasheet-proto :add-child (child-object)
  (send self :dob-children 
        (add-element-to-list (send self :dob-children) child-object)))

(defmeth datasheet-proto :origin (&optional (x nil x?) y)
  (when x? (send self :x+ x)
        (send self :y+ y))
  (list (send self :x+) (send self :y+)))

(defmeth datasheet-proto :click-button (button-number)
  (let* ((ovr (select (send self :overlays) 0))
         (x (+ 2 (select (send ovr :lefts) button-number)))
         (y 10)
         )
    (send ovr :do-click x y nil nil)))

(defmeth datasheet-proto :do-click (x y m1 m2)
  (send self :real-do-click x y m1 m2))

(defmeth datasheet-proto :real-do-click (x y m1 m2)
  (send *vista* :check-running-system-processes x y m1 m2 self)
  (cond
    ((< y (second (send self :margin))) ;(< y 16) 
     (send (first (send self :slot-value 'overlays)) :do-click x y m1 m2))
    (t
;fwy!!! modified next statement
;     (when (not (equal *current-data* (send self :data-object)))
;           (setcd (send self :data-object)))
;fwy!!! added next statement
     (when (not (equal self *current-object*))(setcds self))
     (when (not *stats-menus&tools-disabled*)
           ;(send (send self :data-object) :set-menu&tool-states "disabled")
            (send *var-window* :clear)
            (send *obs-window* :clear)
            ;(setf *stats-menus&tools-disabled* t)
           )
     (let* ((dob (send self :data-object))
            (fw  (send self :field-width))
            (fh  (send self :field-height))
            (lw  (max (list (send self :label-width) (send self :corner-width))))
            (x+ (send self :x+)) 
            (y+ (send self :y+))
            (scrollx (send self :scroll))
            (scrolly (second scrollx))
            (scrollx (first scrollx))
            (old-hot-cell (send self :hot-cell))
            (ready (send self :hot-cell-ready))
            (nobs (send self :nobs))
            (nvar (send self :nvar))
            (new-var nil)
            (new-obs nil)
            (body nil)
            (row nil)
            (col nil)
            (dash self) )
       (cond
         (m2 
          (unless (send self :dash-popup-menu)
                  (send self :dash-popup-menu 
                        (send self :define-datasheet-popup-menu))
                  (send (send dash :dash-popup-menu) :install))
          (send (send self :dash-popup-menu) :popup (- x scrollx) (- y scrolly) self))
         (t
          (when (send self :editable)
                (unless (send self :edited)
                        (send self :edited t)
                        (send dob  :edited t)
                        (send self :redraw-overlays))
                (send dob :array-needs-updating t)
                (setf row (- (ceiling (- y y+) fh) 2))
                (setf col (ceiling (- (- x x+) lw) fw))
               ; (when (and (= row 0) (> col 0))
               ;       (unless (send self :dash-vartype-menu)
               ;               (send self :dash-vartype-menu
               ;                     (send self :define-dash-vartype-menu))
               ;               (send (send dash :dash-vartype-menu) :install))
               ;       (send (send self :dash-vartype-menu)
               ;             :popup (- x scrollx) (- y scrolly) self))
                (when (and (not (and (< row 1) (< col 1)))
                           (and (<= row nobs) (<= col nvar)))
                      (setf body t)
                      (send self :hot-cell (list row col))
                      (send self :reverse-cell-color row col lw fw fh ready t))
                (when (not body)
                      (if (and (= row -1) (= col (+ 1 nvar)) 
                               (not (send dob :ways)))
                          (setf new-var t) (setf new-var nil))
                      (if (and (= row (+ 1 nobs)) (< col 1))
                          (setf new-obs t) (setf new-obs nil)))
                (when old-hot-cell
                      (setf row (first  old-hot-cell))
                      (setf col (second old-hot-cell))
                      (send self :reverse-cell-color row col lw fw fh ready t t))
                (when (not body)
                      (send self :hot-cell nil)
                      (when (or new-var new-obs)
                            (if (send dob :matrices)
                                (send self :expand-mat-datasheet new-var new-obs 1)
                                (send self :expand-mv-datasheet new-var new-obs 1))
                            ))
                (when ready (send self :hot-cell-ready nil)))))))))

(defmeth datasheet-proto :do-key (c m1 m2)
"Method Args: c m1 m2
Senses character c and shift (m1=t) or option (m2=t)"
  (let ((editable (send self :editable))
        (hot (send self :hot-cell))
        (fw  (send self :field-width))
        (fh  (send self :field-height))
        (lw  (max (list (send self :label-width)
                        (send self :corner-width))))
        (nobs (send self :nobs))
        (nvar (send self :nvar))
        (x   nil)
        (y   nil)
        (x+ 0)
        (y+ 0)
        ) 
;(send self :redraw)
;DISPLAYS CHARACTER TYPED
;(format t "~s~% " c)
    (when 
     editable 
     (when 
      hot
      (setf row (first hot))
      (setf col (second hot))
      (setf x (+ x+ lw 1 (* fw (1- col))))
      (setf y (+ y+ 1 (* fh (+ 1 row))))
     ; (send self :reverse-cell-color row col lw fw fh nil)
;(format t "ROW COL X Y ~d ~d ~d ~d" row col x y)
#+macintosh      (case c
        ( (#\C-\ #\C-] #\C-M #\Newline #\Tab #\C-C #\C-^ #\C-_ #\C-A #\C-D)
;            left right return? return   tab  enter  up   down  home  end    
         (send self :move-cell c row col nvar nobs x y lw fw fh m1))
        (t
         (send self :store-and-show-char c row col lw fw fh)))
#+msdos    (case c
        ( (  #\%   #\'   #\&  #\(  #\Tab #\# #\$  #\!  #\" #\Return )
;            left  right up   down   tab end home pgup pgdn  return
         (send self :move-cell c row col nvar nobs x y lw fw fh m1))
        (t (send self :store-and-show-char c row col lw fw fh)))
#+X11   (case c
        ( (  #\;   #\Newline #\[  #\'   #\Tab) ;temp same as msdos
;            left  right     up   down   tab
         (send self :move-cell c row col nvar nobs x y lw fw fh m1))
        (t
         (send self :store-and-show-char c row col lw fw fh)))
      ))))

(defmeth datasheet-proto :store-and-show-char (c row col lw fw fh)
"Method Args: c row col lw fw fh
Method to store and show a non cursor moving character c when in row and col of datasheet with lw label width, fw and fh field width and height."
  (let* ((hot-cell-ready (send self :hot-cell-ready))
         (xywh (send self :cell-size-location row col lw fw fh))
         (data-strings (send self :data-matrix-strings))
         (type-strings (send self :type-strings))
         (ncol (send self :nvar))
         (dob (send self :data-object))
         (x (first  xywh))
         (y (second xywh))
         (w (third  xywh))
         (h (fourth xywh))
         (datum)
         (n?)
         (x+ (send self :x+)) 
         (y+ (send self :y+))
         ) 
    (cond 
      ((not hot-cell-ready) 
       (send self :hot-cell-ready t)
       ;(send self :erase-rect (+ x x+ 2) (+ y y+ 1 (- fh) ) (- w 4) (- h 4))
       (if (eq c #\C-H) ;if delete
           (send self :hot-cell-string "")
           (send self :hot-cell-string (coerce (list c) 'string))))
      (t
       (if (eq c #\C-H)
           (when (> (length (send self :hot-cell-string)) 0)
                 (send self :hot-cell-string
                       (subseq (send self :hot-cell-string) 0 
                               (1- (length (send self :hot-cell-string))))))
           (send self :hot-cell-string (strcat (send self :hot-cell-string)
                                               (coerce (list c) 'string))))))  
    (cond 
      ((and (> row 0) (> col 0)) ;when in main body of table
      ; (send self :draw-cell-text self ':data-matrix-strings
      ;       row col x y w h fw fh lw 2 (1- row) (1- col))      
       (when *realtime-datasheet-update*
             (setf datum (select (send dob :data) 
                           (+ (1- col) (* ncol (1- row)))))
             (setf (select (send dob :data) 
                           (+ (1- col) (* ncol (1- row)))) 
                   (cond
                     ((equal "category" 
                             (string-downcase (select (send dob :types) (1- col))))
                      (send self :draw-cell-text self ':data-matrix-strings
                            row col x y w h fw fh lw 2 (1- row) (1- col)) 
                      (send self :hot-cell-string))
                     (t
                      (setf n? (number-from-string (send self :hot-cell-string)))
                      (cond
                        ((not (or (numberp n?) (equal (string c) "-")))
                         (progn
                          (vista-dialog "Must Be Numeric")
                          (send self :hot-cell-string
                                (select (send self :hot-cell-string)
                                        (iseq (1- (length (send self :hot-cell-string))))))
                          datum))
                        (t
                         (send self :draw-cell-text self ':data-matrix-strings
                               row col x y w h fw fh lw 2 (1- row) (1- col)) 
                         )))))
             ;(pm (send dob :data-matrix))
             ))
      ((< col 1) ;when in labels
       (send self :back-color 'post-it-yellow)
       (send self :draw-cell-text self ':label-strings 
             row col x y w h fw fh lw 0 (1- row))
       (send self :back-color 'white))
      ((= row -1) ;when in variable names
       (send self :back-color 'post-it-yellow)
       (send self :draw-cell-text self ':variable-strings 
             row col x y w h fw fh lw 1 (1- col))
       (send self :back-color 'white))
      ((= row 0) ;when in variable types
       (cond
         ((equal #\c (select (string-downcase (send self :hot-cell-string)) 0))
          (send self :hot-cell-string "Category"))
        ; ((equal #\o (select (string-downcase (send self :hot-cell-string)) 0))
        ;  (send self :hot-cell-string "Ordinal"))
         ((equal #\n (select (string-downcase (send self :hot-cell-string)) 0))
          (send self :hot-cell-string "Numeric"))
        ; ((equal #\f (select (string-downcase (send self :hot-cell-string)) 0))
        ;  (send self :hot-cell-string "Freq"))
        ; ((equal #\l (select (string-downcase (send self :hot-cell-string)) 0))
        ;  (send self :hot-cell-string "Label"))
         (t 
          (help (format nil "Type:~%C for Category or N for Numeric."))
#|All characters accepted.~%O for Ordinal:   (not supported)~%N for Numeric:   1234567890 .,+- sfed accepted. ~%F for Frequency: 1234567890 accepted (not implemented)~%L for Label:     All characters accepted (not implemented)."))
|#
          (send self :hot-cell-string " ")))
       (send self :back-color 'post-it-yellow)
       (send self :draw-cell-text self ':type-strings
             row col x y w h fw fh lw 1 (1- col))
       (send self :back-color 'white))
      )))
  
(defmeth datasheet-proto :draw-cell-text 
  (object message row col x y w h fw fh lw justify element1 &optional element2)
"Args: Object - dataobj; message - message sent to data-object;
row col - of data sheet; x y w h - position and size of cell; fw fh lw field sizes of sheet; justify - 0 1 2 left center right; element1 element2 row and col of dataobj"
  (let ((string nil)
        (maxstring 0)
        (yo (second (send self :origin)))
        (x+ (send self :x+)) 
        (y+ (send self :y+)))
    (if element2 
        (setf (select (send object message) element1 element2)
              (send self :hot-cell-string))
        (setf (select (send object message) element1)
              (send self :hot-cell-string)))
    (send self :erase-rect 
          (+ x x+ 2) 
          (+ y y+ (if (< row 1) 0 1) (- yo))
          (- w 4) 
          (- h (if (< row 1) 4 4)))
    (if element2
        (setf string (select (send object message) element1 element2))
        (setf string (select (send object message) element1))) 
    (if (< col 1) (setf maxstring lw) (setf maxstring fw))
    (when (> (send self :text-width string) (- maxstring 6)) 
          (setf string "*****"))
    (case justify
      (2 (send self :draw-text string (+ x+ (- (+ lw (* col fw)) 3))
               (+ y+ (- (* fh (+ 2 row)) 3)) 2 0))
      (1 (send self :draw-text string (+ x+ (- (+ lw (* col fw)) (floor (/ fw 2)))) 
               (+ y+ (- (* fh (+ 2 row)) 3)) 1 0))
      (0 (send self :draw-text string (+ x+ 3) 
               (+ y+ (- (* fh (+ 2 row)) 3)) 0 0)))
    ))

;#+msdos  #\%   #\'   #\&  #\(  #\Tab #\# #\$  #\!  #\")
;         left  right up   down   tab end home pgup pgdn

(defmeth datasheet-proto :move-cell (c row col nvar nobs xx yy lw fw fh m1)
"Method Args: c row col nvar nobs x y lw fw fh m1
Method to move to another cell by simulating a do-click.  Movement character is c.  In row and col. There are nvar and nobs cols and rows.  Simulated click will be at x and y plus offsets x+ and y+. Fields are fw and fh wide and high. Lables are lw wide. M1 t for shift."
  (let* ((x+ (send self :x+)) 
         (y+ (send self :y+))
         (x (+ xx x+))
         (y (+ yy y+)))
    (when (< col 1) ;when in labels column
     (case c 
       (
#+macintosh(#\C-\ #\C-^) ;left,up
#+msdos    (#\% #\& ) ; was #\; #\[
#+X11    (#\;   #\[)
        (when (> row 1) (send self :do-click x (- y fh) nil nil))) ;up
       (#\Tab
        (if m1 
            (when (> row 1)
                  (send self :do-click 3 (- y fh) nil nil))
            (when (< row nobs)
                  (send self :do-click 3 (+ y fh) nil nil))))
       (
#-msdos #\C-A 
#+msdos #\$
        (send self :do-click (+ lw 3) (+ (* 2 fh) 3) nil nil)) ;home

       (
#-msdos #\C-D 
#+msdos #\#
         (send self :do-click (+ lw -3 (* nvar fw)) 
                    (+ 3 fh (* nobs fh)) nil nil)) ;end
       (t ;down
        (when (< row nobs)
              (send self :do-click x (+ y fh) nil nil)))
       ))
  (when (> col 0) ;when in datasheet columns
     (case c
       (
#+macintosh #\C-\ ;left
#+msdos     #\%   ; was #\;
#+X11       #\;
         (when (and (not (and (= col 1) (= row 1)))
                    (not (and (= col 1) (= row -1))))
         (if (> col 1) 
             (send self :do-click (- x fw) y nil nil)
             (send self :do-click (+ lw -3 (* nvar fw)) (- y fh) nil nil))))

       (
#-msdos  (#\C-] #\C-M #\C-C #\Newline)  ;right
#+msdos  ( #\' #\Return )
         (when (not (and (= col nvar) (= row nobs)))
         (if (< col nvar)
             (send self :do-click (+ x fw) y nil nil)
             (send self :do-click (+ lw 3) (+ y fh) nil nil))))
       (#\Tab ; first in next (previous if shift-tab) row
         (cond 
           ((and (> row 1) (< row nobs))
            (if m1
                (send self :do-click (+ lw 3) (- y fh) nil nil)
                (send self :do-click (+ lw 3) (+ y fh) nil nil)))
           ((and (= row 1) (not m1))
            (send self :do-click (+ lw 3) (+ y fh) nil nil))
           ((and (= row nobs) m1)
            (send self :do-click (+ lw 3) (- y fh) nil nil))))
       (
#+macintosh #\C-^ ;up
#+msdos      #\&  ; was #\[
#+X11     #\[
         (when (or (> row 1) (= row 0))
               (send self :do-click x (- y fh) nil nil)))
       (
#+macintosh #\C-_ ;down
#+msdos     #\(   ; was #\' 
#+X11     #\'
         (when (< row nobs)
         (send self :do-click x (+ y fh) nil nil)))
        (
#-msdos #\C-A 
#+msdos #\$ 
         (send self :do-click (+ lw 3) (+ (* 2 fh) 3) nil nil)) ;home
        (
#-msdos #\C-D 
#+msdos #\#
         (send self :do-click (+ lw -3 (* nvar fw)) 
                    (+ 3 fh (* nobs fh)) nil nil)) ;end
        ))))


(defmeth datasheet-proto :do-motion (x y)
  (let* ((margin (send self :margin))
         )
  (when *auto-activate* (send self :active-window))
    (cond
      ((and (> (second margin) 0) (<= y (second margin)))
       (send self :cursor 'solid-arrow))
      ((and (> (fourth margin) 0)
            (> y (- (send self :canvas-height) (fourth margin))))
       (send self :cursor 'solid-arrow))
      ((and (> (first margin) 0) (<= x (first margin)))
       (send self :cursor 'solid-arrow))
      ((and (> (third margin) 0) 
            (> x (- (send self :canvas-width) (third margin))))
       (send self :cursor 'solid-arrow))
      (t
       (when (not (eq (send self :cursor) (send self :set-mode-cursor)))
             (send self :cursor) (send self :set-mode-cursor))
       (send self :do-brush-motion x y)))
    t))